home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gnat1792.zip / gnat179b / t-adainc / s-retide.adb < prev    next >
Text File  |  1994-05-19  |  5KB  |  135 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                 GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
  4. --                                                                          --
  5. --               S Y S T E M . R E A L _ T I M E . D E L A Y S              --
  6. --                                                                          --
  7. --                                  B o d y                                 --
  8. --                                                                          --
  9. --                             $Revision: 1.4 $                             --
  10. --                                                                          --
  11. --           Copyright (c) 1991,1992,1993, FSU, All Rights Reserved         --
  12. --                                                                          --
  13. --  GNARL is free software; you can redistribute it and/or modify it  under --
  14. --  terms  of  the  GNU  Library General Public License as published by the --
  15. --  Free Software Foundation; either version 2, or  (at  your  option)  any --
  16. --  later  version.   GNARL is distributed in the hope that it will be use- --
  17. --  ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of --
  18. --  MERCHANTABILITY  or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
  19. --  eral Library Public License for more details.  You should have received --
  20. --  a  copy of the GNU Library General Public License along with GNARL; see --
  21. --  file COPYING. If not, write to the Free Software Foundation,  675  Mass --
  22. --  Ave, Cambridge, MA 02139, USA.                                          --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with System.Compiler_Exceptions;
  27. --  Uses, function Current_Exceptions
  28.  
  29. with System.Task_Timer_Service;
  30. --  Uses, object Objects
  31. --        procedure Service_Entries
  32.  
  33. with System.Tasking;
  34.  
  35. with Unchecked_Conversion;
  36.  
  37. package body System.Real_Time.Delays is
  38.  
  39.    use Tasking.Protected_Objects;
  40.    use Tasking;
  41.  
  42.    package Timer renames System.Task_Timer_Service.Timer;
  43.  
  44.    function To_Access is new
  45.      Unchecked_Conversion (System.Address, Protection_Access);
  46.  
  47.    package body Delay_Until_Object is
  48.  
  49.       procedure Service_Entries (Pending_Serviced : out Boolean) is
  50.  
  51.          P : System.Address;
  52.  
  53.          subtype PO_Entry_Index is Protected_Entry_Index
  54.            range Null_Protected_Entry .. 1;
  55.  
  56.          Barriers : Tasking.Barrier_Vector (1 .. 1)  := (others => true);
  57.          --  No barriers. always true barrier
  58.  
  59.          E : PO_Entry_Index;
  60.  
  61.          PS : Boolean;
  62.  
  63.          Cumulative_PS : Boolean := False;
  64.  
  65.       begin
  66.          loop
  67.             --  Get the next queued entry or the pending call
  68.             --  (if no barriers are true)
  69.  
  70.             Tasking.Protected_Objects.Next_Entry_Call
  71.               (To_Access (Object'Address), Barriers, P, E);
  72.  
  73.             begin
  74.                case E is
  75.  
  76.                   --  No pending call to serve
  77.  
  78.                   when Null_Protected_Entry =>
  79.                      exit;
  80.  
  81.                   --  Call to be served
  82.  
  83.                   when 1 =>
  84.  
  85.                      --  Lock the object before requeueing
  86.                      Tasking.Protected_Objects.Lock
  87.                        (To_Access (Timer.Object'Address));
  88.  
  89.                      begin
  90.                         --  Requeue on the timer for the service. Parameter is
  91.                         --  passed along as Object.Call_In_Progress.Param
  92.  
  93.                         Requeue_Protected_Entry (
  94.                           Object => To_Access (Object'Address),
  95.                           New_Object => To_Access (Timer.Object'Address),
  96.                           E => 3,
  97.                           With_Abort => True);
  98.                         Timer.Service_Entries (PS);
  99.                         Tasking.Protected_Objects.Unlock
  100.                           (To_Access (Timer.Object'Address));
  101.  
  102.                      --  Neither Requeue nor Service_Entries should raise
  103.                      --  an exception; the exception should be saved. ???
  104.  
  105. --                   exception
  106. --                      when others =>
  107. --                         Timer.Service_Entries;
  108. --                         raise;
  109.                      end;
  110.                end case;
  111.  
  112.             exception
  113.                when others =>
  114.                   Tasking.Protected_Objects.Exceptional_Complete_Entry_Body (
  115.                     Object => To_Access (Object'Address),
  116.                     Ex => Compiler_Exceptions.Current_Exception,
  117.                     Pending_Serviced => PS);
  118.             end;
  119.  
  120.             Cumulative_PS := Cumulative_PS or PS;
  121.          end loop;
  122.  
  123.          Pending_Serviced := Cumulative_PS;
  124.       end Service_Entries;
  125.  
  126.    --  Initialization for package body of Delay_Until_Object
  127.  
  128.    begin
  129.       Initialize_Protection
  130.         (To_Access (Object'Address), Tasking.Unspecified_Priority);
  131.  
  132.    end Delay_Until_Object;
  133.  
  134. end System.Real_Time.Delays;
  135.